home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / WAFPEGTP / AWINDOW.PAS next >
Pascal/Delphi Source File  |  1994-01-16  |  19KB  |  709 lines
  1. unit awindow;
  2. {
  3. some simple windowing code, derived from various public domain sources
  4. rml
  5. January 1994
  6. note, needs fastscrn.obj to be linked in
  7.  
  8.     Copyright (C) 1992  Dr Ross Lazarus
  9.  
  10.     This program is free software; you can redistribute it and/or modify
  11.     it under the terms of the GNU General Public License as published by
  12.     the Free Software Foundation; either version 1, or (at your option)
  13.     any later version.
  14.  
  15.     This program is distributed in the hope that it will be useful,
  16.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  17.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18.     GNU General Public License for more details.
  19.  
  20.     You should have received a copy of the GNU General Public License
  21.     along with this program; if not, write to the Free Software
  22.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24.     Dr Ross Lazarus is the original copyright holder of this code.
  25.     Email: rossl@gmu.wh.su.edu.au
  26.     Mail: Department of Community Medicine,
  27.           Westmead Hospital
  28.           Westmead, NSW 2145
  29.           Australia
  30.     Fax: (+61 2) 689 1049
  31.  
  32.  
  33.  
  34. }
  35.  
  36. interface
  37. uses dos,crt;
  38.  
  39. CONST Maxwindow = 64;   { No. of slots on the window stack }
  40.       Linebytes = 160;  { Bytes/screen line in 80 col modes}
  41.       Sidestep : integer = 3;     { Horiz. offset for `walking' menus }
  42.       Downstep : integer = 1;     { Vert. offset for `walking' menus }
  43.       Root = 0;         { WinID of the Root window}
  44.  
  45. TYPE  String80 = STRING[80];
  46.       Btype = (Rev,Norm,Drev,Dnorm,none); { Border type }
  47.       Stype = (Shad,Noshad);         { Shadow present }
  48.       WinID = 0..Maxwindow;          { Window handle }
  49.      Curtype  = (Off, Big, Small);
  50.  
  51. var
  52.      bfb,bff,sf,sb,fc,bc,ifc,ibc,backfillf,backfillb : byte;
  53.  
  54.  
  55.  
  56. {
  57. major bug fixed rml september 1989
  58. the screen image captured by getmem was not being freed up
  59. freemem added in movewindowdata
  60. }
  61.  
  62. {-----------------------------------------------------------
  63.     An extension of the Turbo window manager to support
  64.     multiple windows.
  65. ------------------------------------------------------------}
  66.  
  67. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  68. Add a title to the top left window border.
  69. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  70. PROCEDURE WindowTitle(Title:  String80);
  71.  
  72. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  73. Create and display a new window.  Its handle can be obtained
  74. from Lastwin.
  75. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  76. PROCEDURE Window(Ux,Uy,Lx,Ly,Fore,Back:  Byte;  Border:  Btype;
  77. Shadow:  Stype);
  78.  
  79. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  80. Destroy window and its contents permanently.
  81. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  82. PROCEDURE CloseWindow;
  83.  
  84.  
  85. implementation
  86.  
  87. type
  88.   DisplayType = (Monochrome, CGA, EGA, MCGA, VGA);
  89. var
  90.   BaseOfScreen : Word;       {Base address of video memory}
  91.   WaitForRetrace : Boolean;  {Check for snow on color cards?}
  92.   Speed : longint;           {delay factor for growbox routine}
  93.  
  94.   {$L FASTSCRN}
  95.  
  96.   {$F+}
  97.   Procedure FastWrite(Col,Row,Attr:byte; St:string); external;
  98.   Procedure PlainWrite(Col,Row:byte; St:string); external;
  99.   Function CurrentDisplay: DisplayType; external;
  100.   Function CurrentVideoMode: Byte; external;
  101.   {$F-}
  102.  
  103. Procedure InitFastWrite;
  104. {
  105. Initializes WaitForRetrace and BaseOfScreen
  106. }
  107.  
  108. begin  {InitFastWrite}
  109.     if CurrentVideoMode = 7 then
  110.        BaseOfScreen := $B000  {Mono}
  111.     else
  112.        BaseOfScreen := $B800; {Color}
  113.     WaitForRetrace := (CurrentDisplay = CGA);
  114. end;
  115. {InitFastWrite}
  116.  
  117.  
  118. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  119.      These primitive functions return single or double
  120.      horizontal line segments, for use in string expresions.
  121. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  122.  
  123. FUNCTION Horiz(Len:  Byte):  String80;
  124. CONST Hineseg = '────────────────────────────────────────────────────────────────────────────────';
  125.  
  126. BEGIN
  127.   Horiz := Copy(Hineseg, 1, Len)
  128. END;
  129.  
  130. FUNCTION DHoriz(Len:  Byte):  String80;
  131. CONST Hlineseg = '════════════════════════════════════════════════════════════════════════════════';
  132.  
  133. BEGIN
  134.   DHoriz := Copy(Hlineseg, 1, Len)
  135. END;
  136.  
  137. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  138.      Draw single or double horizontal and vertical lines of
  139.      specified length.
  140. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  141.  
  142. PROCEDURE Hline(X1, Y1, Len:  Byte);
  143. BEGIN
  144.   fastwrite(X1, Y1,textattr,Horiz(Len));
  145. END;
  146.  
  147. PROCEDURE Vline(X1, Y1, Len: Byte);
  148. VAR I:  Byte;
  149. BEGIN
  150.   FOR I := Y1 TO Y1+Len DO
  151.     fastwrite(X1, I,textattr,'│');
  152. END;
  153.  
  154. PROCEDURE DHline(X1, Y1, Len:  Byte);
  155. BEGIN
  156.   fastwrite(X1, Y1,textattr,DHoriz(Len));
  157. END;
  158.  
  159. PROCEDURE DVline(X1, Y1, Len: Byte);
  160. VAR I: Byte;
  161.  
  162. BEGIN
  163.   FOR I := Y1 TO Y1+Len DO
  164.       fastwrite(X1, I,textattr,'║');
  165. END;
  166.  
  167. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  168. Draw single or double boxes of specified width and depth.
  169. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  170.  
  171. PROCEDURE Box(X1, Y1, Wide, Deep:  Byte);
  172. BEGIN
  173.   fastwrite(X1, Y1,textattr, '┌'+Horiz(Wide)+'┐');
  174.   Vline(X1, Y1+1, Deep);
  175.   Vline(X1+Wide+1, Y1+1, Deep);
  176.   fastwrite(X1, Y1 + succ(deep),textattr,'└'+Horiz(Wide)+'┘');
  177. END;
  178.  
  179. PROCEDURE DBox(X1, Y1, Wide, Deep: Byte);
  180. BEGIN
  181.   fastwrite(X1, Y1 ,textattr, '╔'+Dhoriz(Wide)+'╗');
  182.   Dvline(X1, Y1+1, Deep);
  183.   Dvline(X1+Wide+1, Y1+1, Deep);
  184.   fastwrite(X1, Y1 + succ(deep),textattr,'╚'+Dhoriz(Wide)+'╝');
  185. end;
  186.  
  187.  
  188. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  189.   Return larger or smaller of two integer values.
  190. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  191.  
  192. FUNCTION Max(A, B: Integer): Integer;
  193.  
  194. BEGIN
  195.   IF A > B THEN Max := A ELSE Max := B
  196. END;
  197.  
  198. FUNCTION Min(A, B: Integer): Integer;
  199. BEGIN
  200.  
  201.      IF A < B THEN Min := A ELSE Min := B
  202. END;
  203.  
  204. {- - - - - - - - - - - -- - - - - - - - - - - - - - - - - - - -
  205.        Return a string of Num spaces.
  206. - - - - - - - - - - - - - - - - - - - - -- - - - - - - - - - - -}
  207.  
  208. FUNCTION Spaces(Num: Word): String80;
  209. CONST Blanks =  '                                                                                ';
  210. BEGIN
  211.   if (num > 0) then
  212.      Spaces := Copy(Blanks, 1, Num)
  213.   else
  214.       spaces := '';
  215. END;
  216. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  217.     Return the argument string stripped of leading and
  218.     trailing (but not embedded) spaces.
  219. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  220.  
  221. FUNCTION NoSpaces(S: STRING): STRING;
  222. VAR Lead, Trail: Integer;
  223. BEGIN
  224.   Lead := 1;
  225.   WHILE S[Lead] = ' ' DO inc(Lead);
  226.   Trail := Length(S);
  227.   WHILE S[Trail]= ' ' DO dec(Trail);
  228.   NoSpaces := Copy(S, Lead, Trail - Lead + 1)
  229. END;
  230.  
  231.  
  232. function trim(trime : String) : String;
  233. { trim trailing blanks by adjusting the length byte at trime[0] }
  234.  
  235. const
  236.      blank = ' ';
  237.  
  238. var
  239.    l : integer;
  240.  
  241. begin
  242.      l := ord(trime[0]);
  243.      while (l > 0) and (trime[l] = blank) do
  244.            l := pred(l);
  245.      trime[0] := chr(l);
  246.      trim := trime;
  247. end; { trim }
  248.  
  249.  
  250. VAR  Shadfore, Shadback: Byte; { Set global shadow colours }
  251.      Vseg: Word;          { Start segment of video buffer }
  252.  
  253.  
  254. {===========================================================}
  255.  
  256.  
  257. procedure initcol;
  258. {
  259. fake some colors
  260. }
  261. var
  262. regs : registers;
  263. mhf,mhb,mf,mb,mbf,mbb,bf,bb,tf,tb,wf,wb,sf,sb : integer;
  264.  
  265. begin
  266.   { Check for monochrome or colour adaptor}
  267.   Regs.AX := $0F00;
  268.   Intr($10, Regs);
  269.   IF Regs.AL = 7 THEN
  270.      {If (BaseOfScreen = $B000) then}
  271.         begin   { mono monitor }
  272.           mhf := darkgray;
  273.           mhb := blue;
  274.           mf := lightgray;
  275.           mb := blue;
  276.           mbf := black;
  277.           mbb := lightgray;
  278.           bf := lightgray;
  279.           bb := blue;
  280.           tf := lightgray;
  281.           tb := blue;
  282.           wf := darkgray;
  283.           wb := blue;
  284.         end
  285.         else
  286.         begin { colour }
  287.              mhf := lightcyan;
  288.              mhb := blue;
  289.              mf := yellow;
  290.              mb := blue;
  291.              mbf := yellow;
  292.              mbb := red;
  293.              bf := lightcyan;
  294.              bb := blue;
  295.              tf := yellow;
  296.              tb := blue;
  297.              wf := yellow;
  298.              wb := red;
  299.         end;
  300.         fc := tf;
  301.         bc := tb;
  302.         ifc := wf;
  303.         ibc := wb;
  304.         bfb := tb;
  305.         bff := tf;
  306.         sf := darkgray;
  307.         sb := black;
  308.         shadfore := sf;
  309.         shadback := sb;
  310. end;
  311.  
  312. TYPE Dirn = (Toheap,Fromheap);   { Direction flag for MoveWindowData}
  313.      WinPtr = ^Windowdescriptor;
  314.      Windowdescriptor
  315.              = RECORD
  316.                  Parent: WinID;
  317.                  Ux,Uy,Lx,Ly,Fore,Back,X,Y: Byte;
  318.                  Border: Btype;
  319.                  Shadow: Stype;
  320.                  P: Pointer;
  321.                END;
  322.  
  323. VAR Regs: Registers;
  324.     Top, Active: WinID;         { Stack pointer and marker }
  325.     W: ARRAY[WinID] OF WinPtr;  { Window stack }
  326.  
  327. {-----------------------------------------------------------
  328.     These procedures and functions redefine their equivalents
  329.     in the Turbo Crt unit. NOTE: Windmax, Windmin and
  330.     TextAttr were variables not functions in Crt.
  331. ------------------------------------------------------------}
  332.  
  333. FUNCTION WindMax: Word;
  334. BEGIN
  335.   WindMax := pred(W[Active]^.Ly) * 256 + pred(W[Active]^.Lx);
  336. END;
  337.  
  338. FUNCTION WindMin: Word;
  339. BEGIN
  340.   WindMin := pred(W[Active]^.Uy) * 256 + pred(W[Active]^.Ux);
  341. END;
  342.  
  343. FUNCTION WhereX: Byte;
  344. BEGIN
  345.   WhereX := W[Active]^.X
  346. END;
  347.  
  348. FUNCTION WhereY: Byte;
  349. BEGIN
  350.   WhereY := W[Active]^.Y
  351. END;
  352.  
  353. PROCEDURE Gotoxy(X,Y: Byte);
  354. BEGIN
  355.   W[Active]^.X := X;
  356.   W[Active]^.Y := Y;
  357.   Crt.Gotoxy(X,Y)
  358. END;
  359.  
  360. PROCEDURE Textcolour(Colour: Byte);
  361. BEGIN
  362.   W[Active]^.Fore := Colour;
  363.   Crt.Textcolor(Colour)
  364. END;
  365.  
  366. PROCEDURE Textbackground(Colour: Byte);
  367. BEGIN
  368.   W[Active]^.Back := Colour;
  369.   Crt.Textbackground(Colour)
  370. END;
  371.  
  372. FUNCTION TextAttr: Byte;
  373. BEGIN
  374.   TextAttr := W[Active]^.Fore + W[Active]^.Back * 16
  375. END;
  376.  
  377. {-----------------------------------------------------------
  378.     More convenient substitutes for TextAttr; return
  379.     foreground and background separately.
  380. ------------------------------------------------------------}
  381.  
  382. FUNCTION FCol: Byte;
  383. BEGIN
  384.   FCol := W[Active]^.Fore
  385. END;
  386.  
  387. FUNCTION BCol: Byte;
  388. BEGIN
  389.   BCol := W[Active]^.Back
  390. END;
  391.  
  392. {-----------------------------------------------------------
  393.     Return current cursor coordinates relative to whole
  394.     screen.
  395. ------------------------------------------------------------}
  396.  
  397. FUNCTION AbsX: Byte;
  398. BEGIN
  399.   AbsX := W[Active]^.Ux+WhereX
  400. END;
  401.  
  402. FUNCTION AbsY: Byte;
  403. BEGIN
  404.   AbsY := W[Active]^.Uy+WhereY
  405. END;
  406.  
  407. {-----------------------------------------------------------
  408.     Return cursor coordinates for next `walking' position.
  409. ------------------------------------------------------------}
  410. FUNCTION AutoX: Byte;
  411. BEGIN
  412.   AutoX := AbsX+Sidestep;
  413. END;
  414.  
  415. FUNCTION AutoY: Byte;
  416. BEGIN
  417.   AutoY := AbsY+Downstep;
  418. END;
  419.  
  420. {-----------------------------------------------------------
  421.     Return top of stack and currently selected windows.
  422. ------------------------------------------------------------}
  423.  
  424. FUNCTION Lastwin: Byte;
  425. BEGIN
  426.   Lastwin := Top
  427. END;
  428.  
  429. FUNCTION Selwin: Byte;
  430. BEGIN
  431.   Selwin := Active
  432. END;
  433.  
  434. {-----------------------------------------------------------
  435.     Make window whose handle is Wnum the currently selected
  436.     window.
  437. ------------------------------------------------------------}
  438.  
  439. PROCEDURE SelectWindow(Wnum: WinID);
  440. BEGIN
  441.   WITH W[Wnum]^ DO
  442.   BEGIN
  443.     Active := Wnum;
  444.     Textcolour(Fore);
  445.     TextBackground(Back);
  446.     IF (Wnum = Root) then
  447.        Crt.Window(1,1,80,25)  { Root window has no border}
  448.     else
  449.     if ((border = none) and (shadow = noshad)) then
  450.        Crt.Window(Ux,Uy,Lx,Ly)
  451.     else
  452.         Crt.Window(Ux+1,Uy+1,Lx-1,Ly-1);
  453.     Gotoxy(X,Y);
  454.   END;
  455. END;
  456.  
  457. {-----------------------------------------------------------
  458. Draw a drop shadow at right and bottom edge of the selected
  459. window. Modifies video buffer contents directly, bypassing
  460. BIOS.
  461. ------------------------------------------------------------}
  462.  
  463. PROCEDURE DrawShadow(Fore, Back: Byte);
  464. VAR I: Byte;
  465. BEGIN
  466.   FOR I := W[Active]^.Uy TO W[Active]^.Ly DO
  467.      Mem[Vseg:I*Linebytes+W[Active]^.Lx*2+1] := Back*16+Fore;
  468.   FOR I := W[Active]^.Ux TO W[Active]^.Lx DO
  469.      Mem[Vseg:W[Active]^.Ly*Linebytes+I*2+1] := Back*16+Fore
  470. END;
  471.  
  472. {-----------------------------------------------------------
  473.     Move the previous screen contents covered by a new window
  474.     To or From a storage space allocated on the heap.
  475. ------------------------------------------------------------}
  476.  
  477. PROCEDURE MoveWindowData(Wnum: WinID; Direction: Dirn);
  478. VAR I,Deep,Wide,Startaddr: Word;
  479. BEGIN
  480.   { Calculate window dimensions}
  481.   Deep := succ(W[Wnum]^.Ly) - W[Wnum]^.Uy;
  482.   Wide := (succ(W[Wnum]^.Lx) - W[Wnum]^.Ux) * 2;
  483.   { Calculate start offset of first window line in video buffer}
  484.   Startaddr:= pred(W[Wnum]^.Uy) * Linebytes + pred(W[Wnum]^.Ux)*2;
  485.   { Must save area covered by shadow too, if there is one}
  486.   IF (W[Wnum]^.Shadow = Shad)
  487.   THEN BEGIN
  488.          inc(Deep);
  489.          inc(Wide,2);
  490.        END;
  491.  
  492.   IF Direction = Toheap
  493.   THEN BEGIN
  494.          { Allocate storage space}
  495.          Getmem(W[Wnum]^.P, Deep * Wide * 2);
  496.          { Move screen data to heap, one line at a time}
  497.          FOR I := 0 TO pred(Deep) DO
  498.           Move(Mem[Vseg:Startaddr + I*Linebytes],
  499.               Mem[Seg(W[Wnum]^.P^)
  500.                :Ofs(W[Wnum]^.P^)+I*Wide], Wide)
  501.        END
  502.   ELSE  { Move stored heap data back to screen buffer}
  503.   begin
  504.         FOR I := 0 TO pred(Deep) DO
  505.           Move(Mem[Seg(W[Wnum]^.P^)
  506.                 :Ofs(W[Wnum]^.P^)+ I*Wide],
  507.               Mem[Vseg:Startaddr + I*Linebytes], Wide);
  508.        (* major fix - this line frees up the no longer needed screen image *)
  509.        (* off the heap rml September 1989                                  *)
  510.         freemem(W[Wnum]^.P, Deep * Wide * 2);
  511.   end;
  512. END;
  513. {- - - - - - - - - - - - - - - - --- - - - - - - - -
  514.     Create window image on screen.
  515. - - - - - - - - - - - - - -- - - - - - - - - - - - - -}
  516.  
  517. PROCEDURE DrawWindow;
  518. BEGIN
  519.   Crt.Window(1, 1, 80, 25);
  520.   WITH W[Active]^ DO
  521.   BEGIN
  522.     IF (Border = Rev) OR (Border = Drev)
  523.     THEN BEGIN
  524.            Crt.Textcolor(ifc);
  525.            Crt.TextBackground(ibc);
  526.            IF Border = Rev
  527.            THEN Box(Ux, UY, Lx-Ux-1, Ly-Uy-1)
  528.            ELSE
  529.            if (border <> none) then
  530.               DBox(Ux, Uy, Lx-Ux-1, Ly-Uy-1)
  531.          END
  532.     ELSE BEGIN
  533.            Crt.Textcolor(bff);
  534.            Crt.TextBackground(bfb);
  535.            IF Border = Norm
  536.            THEN Box(Ux, Uy, Lx-Ux-1, Ly-Uy-1)
  537.            ELSE if (border <> none) then
  538.                 DBox(Ux, Uy, Lx-Ux-1, Ly-Uy-1)
  539.          END;
  540.     IF Shadow = Shad THEN DrawShadow(Shadfore, Shadback)
  541.   END
  542. END;
  543.  
  544. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  545. Create and display a new window.  Its handle can be       obtained
  546. from Lastwin.
  547. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - }
  548.  
  549. PROCEDURE Window(Ux,Uy,Lx,Ly,Fore,Back:  Byte;  Border:  Btype;
  550. Shadow:  Stype);
  551. var
  552.    deep,wide : byte;
  553.    c : char;
  554. BEGIN
  555.   {Pre-increment stack pointer}
  556.   Inc(Top);
  557.  
  558.   {Check for stack overflow}
  559.   IF Top > Maxwindow
  560.   THEN BEGIN
  561.          SelectWindow(Root);
  562.          Write('Too many windows: max permitted is ', Maxwindow+1);
  563.          clreol;
  564.          Halt(2);
  565.        END;
  566.  
  567.   Deep := succ(Ly) - Uy;
  568.   Wide := (succ(Lx) - Ux) * 2;
  569.   if (maxavail < (deep*wide*2)) then
  570.   BEGIN
  571.          SelectWindow(Root);
  572.          Writeln('Not enough memory to create required window');
  573.          clreol;
  574.          halt(1);
  575.   END;
  576.  
  577.   {Allocate space for window descriptor }
  578.   New(W[Top]);
  579.  
  580.   { Fill in new descriptor}
  581.   if (shadow <> noshad) then
  582.   begin
  583.        ux := min(ux,79);
  584.        uy := min(uy,24);
  585.        lx := max(lx,1);
  586.        ly := max(ly,1);
  587.        W[Top]^.Ux := max(Ux,1);  { "Bounce off" screen edges}
  588.        W[Top]^.Uy := max(uy,1);
  589.        W[Top]^.Lx := Min(Lx, 79);
  590.        W[Top]^.Ly := Min(Ly, 24);
  591.   end
  592.   else
  593.   begin
  594.        ux := min(ux,80);
  595.        uy := min(uy,25);
  596.        lx := max(lx,1);
  597.        ly := max(ly,1);
  598.        W[Top]^.Ux := max(Ux,1);  { "Bounce off" screen edges}
  599.        W[Top]^.Uy := max(uy,1);
  600.        W[Top]^.Lx := Min(Lx, 80);
  601.        W[Top]^.Ly := Min(Ly, 25);
  602.   end;
  603.   W[Top]^.Fore := Fore;
  604.   W[Top]^.Back := Back;
  605.   W[Top]^.X := 1;
  606.   W[Top]^.Y := 1;
  607.   if (w[top]^.ly > 24) or (w[top]^.lx >= 79) then
  608.      shadow := noshad;
  609.   W[Top]^.Border := Border;
  610.   W[Top]^.Shadow := Shadow;
  611.   W[Top]^.Parent := Active;
  612.  
  613.   Active := Top;
  614.   MoveWindowData(Active, Toheap);
  615.   DrawWindow;
  616.   SelectWindow(Active);
  617.   ClrScr
  618. END;
  619.  
  620. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  621. Add a title to the top left window border.
  622. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  623.  
  624. PROCEDURE WindowTitle(Title:  String80);
  625. var
  626.    tlen,spos : integer;
  627.  
  628. BEGIN
  629.   title := trim(title);
  630.   tlen := length(title);
  631.   Crt.Window(1, 1, 80, 25);
  632.   WITH W[Active]^ DO
  633.   BEGIN
  634.    IF (Border = Rev) OR (Border = Drev)
  635.    THEN
  636.    BEGIN
  637.           Crt.Textcolor(ifc);
  638.           Crt.TextBackground(ibc)
  639.    END
  640.    ELSE
  641.    BEGIN
  642.           Crt.Textcolor(bff);
  643.           Crt.TextBackground(bfb)
  644.    END;
  645.    spos := ux + ((lx - ux) div 2) - (tlen div 2);
  646.    Crt. GotoXY(succ(spos), Uy);
  647.    write(title);
  648.   end;
  649.   SelectWindow(Active)
  650. END;
  651.  
  652. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  653. Destroy window and its contents permanently.
  654. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  655.  
  656. PROCEDURE CloseWindow;
  657. BEGIN
  658.   IF Top > 0                    { Cannot close Root window!}
  659.   THEN BEGIN
  660.     MoveWindowData(Top,Fromheap);  { Erase window image + free memory }
  661.     Active := W[Top]^.Parent;     { Reinstate parent window}
  662.  
  663.     Dispose(W[Top]^.P);         { Free up screen data }
  664.     Dispose(W[Top]);            { Free up descriptor}
  665.     Dec(Top);                   { Pop stack}
  666.     SelectWindow(Active)
  667.   END
  668. END;
  669.  
  670. procedure winit;
  671. {- - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  672.     Initialise window system.
  673. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -}
  674.  
  675. BEGIN
  676.   { Check for monochrome or colour adaptor}
  677.   Regs.AX := $0F00;
  678.   Intr($10, Regs);
  679.   IF Regs.AL = 7 THEN Vseg := $B000 ELSE Vseg := $B800;
  680.  
  681.   { Initialise stack pointer}
  682.   Top := 0;
  683.  
  684.   { Set up descriptor for Root window}
  685.   New(W[Root]);
  686.   W[Root]^.Parent := Root;
  687.   W[Root]^.Ux := 1;
  688.   W[Root]^.Uy := 1;
  689.   W[Root]^.Lx := 80;
  690.   W[Root]^.Ly := 25;
  691.   W[Root]^.Fore := White;
  692.   W[Root]^.Back := Black;
  693.   W[Root]^.X := crt.wherex;
  694.   W[Root]^.Y := crt.wherey;
  695.   WITH W[Root]^ DO
  696.   BEGIN
  697.     Active := root;
  698.     Textcolour(Fore);
  699.     TextBackground(Back);
  700.   end; {* patch rml 7/8/91 to stop screen clearing *}
  701. END;
  702.  
  703. begin
  704.      winit;
  705.      initcol;
  706.      initfastwrite;
  707.      speed := 200;
  708. end.
  709.